home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b2stc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  20.8 KB  |  872 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b2stc.c,v 1.4 85/08/22 16:55:56 timo Exp $
  5. */
  6.  
  7. /* B (intra-unit) type check */
  8.  
  9. #include "b.h"
  10. #include "b1obj.h"
  11. #include "b2nod.h"
  12. #include "b2syn.h"         /* temporary? for Cap in tc_refinement */
  13. #include "b2tcP.h"
  14. #include "b2tcU.h"
  15. #include "b2tcE.h"
  16. #include "b3err.h"
  17.  
  18. /* ******************************************************************** */
  19.  
  20. Hidden value refname;
  21.  
  22. /*
  23.  * if in commandsuite of refinement: 
  24.  *    holds refinement name;
  25.  * if in commandsuite of yield unit:
  26.  *     holds B-text "returned value" 
  27.  *        (used in error messages, no confusion possible)
  28.  * else
  29.  *    Vnil
  30.  * To be used in tc_return()
  31.  */
  32.  
  33. /* ******************************************************************** */
  34.  
  35. Forward polytype pt_expr();
  36.  
  37. Visible Procedure type_check(v) parsetree v; {
  38.     typenode n;
  39.     extern bool extcmds; /* Set in main by -E option */
  40.  
  41.     if (extcmds || !still_ok || v EQ NilTree)
  42.         return;
  43.     n = nodetype(v);
  44.     curline= v; curlino= one;
  45.     start_vars();
  46.     refname = Vnil;
  47.     usetypetable(mk_elt());
  48.     if (Unit(n)) tc_unit(v);
  49.     else if (Command(n)) tc_command(v);
  50.     else if (Expression(n)) p_release(pt_expr(v));
  51.     else syserr(MESS(2300, "wrong argument of 'type_check'"));
  52.     end_vars();
  53.     deltypetable();
  54. }
  55.  
  56. #define TABSIZE 72
  57.  
  58. Hidden    Procedure (*(uni_tab[TABSIZE]))(); /*Units*/
  59. Hidden    Procedure (*(cmd_tab[TABSIZE]))(); /*Commands*/
  60. Hidden    polytype  (*(exp_tab[TABSIZE]))(); /*Expressions*/
  61. Hidden    Procedure (*(tes_tab[TABSIZE]))(); /*Tests*/
  62.  
  63. #define FF First_fieldnr
  64.  
  65. Hidden Procedure tc_node(v, tab) parsetree v; int (*(tab[]))(); {
  66.     auto (*f)()= tab[nodetype(v)];
  67.     switch (Nbranches(v)) { 
  68.         case 0: (*f)(); break; 
  69.         case 1: (*f)(*Branch(v,FF)); break; 
  70.         case 2: (*f)(*Branch(v,FF), *Branch(v,FF+1)); break; 
  71.         case 3: (*f)(*Branch(v,FF), *Branch(v,FF+1),
  72.             *Branch(v,FF+2)); break; 
  73.         case 4: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  74.             *Branch(v,FF+2), *Branch(v,FF+3)); break; 
  75.         case 5: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  76.             *Branch(v,FF+2), *Branch(v,FF+3), 
  77.             *Branch(v,FF+4)); break; 
  78.         case 6: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  79.             *Branch(v,FF+2), *Branch(v,FF+3), 
  80.             *Branch(v,FF+4), *Branch(v,FF+5)); break; 
  81.         case 7: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  82.             *Branch(v,FF+2), *Branch(v,FF+3), 
  83.             *Branch(v,FF+4), *Branch(v,FF+5), 
  84.             *Branch(v,FF+6)); break;
  85.         case 8: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  86.             *Branch(v,FF+2), *Branch(v,FF+3), 
  87.             *Branch(v,FF+4), *Branch(v,FF+5), 
  88.             *Branch(v,FF+6), *Branch(v,FF+7)); break;
  89.         case 9: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  90.             *Branch(v,FF+2), *Branch(v,FF+3), 
  91.             *Branch(v,FF+4), *Branch(v,FF+5), 
  92.             *Branch(v,FF+6), *Branch(v,FF+7),
  93.             *Branch(v,FF+8)); break;
  94.         default: syserr(MESS(2301, "Wrong size node in tc_node"));
  95.     }
  96. }
  97.  
  98. Hidden polytype pt_node(v, tab) parsetree v; polytype (*(tab[]))(); {
  99.     polytype (*f)()= tab[nodetype(v)];
  100.     switch (Nbranches(v)) { 
  101.         case 0: (*f)(); break; 
  102.         case 1: (*f)(*Branch(v,FF)); break; 
  103.         case 2: (*f)(*Branch(v,FF), *Branch(v,FF+1)); break; 
  104.         case 3: (*f)(*Branch(v,FF), *Branch(v,FF+1),
  105.             *Branch(v,FF+2)); break; 
  106.         case 4: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  107.             *Branch(v,FF+2), *Branch(v,FF+3)); break; 
  108.         case 5: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  109.             *Branch(v,FF+2), *Branch(v,FF+3), 
  110.             *Branch(v,FF+4)); break; 
  111.         case 6: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  112.             *Branch(v,FF+2), *Branch(v,FF+3), 
  113.             *Branch(v,FF+4), *Branch(v,FF+5)); break; 
  114.         case 7: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  115.             *Branch(v,FF+2), *Branch(v,FF+3), 
  116.             *Branch(v,FF+4), *Branch(v,FF+5), 
  117.             *Branch(v,FF+6)); break;
  118.         case 8: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  119.             *Branch(v,FF+2), *Branch(v,FF+3), 
  120.             *Branch(v,FF+4), *Branch(v,FF+5), 
  121.             *Branch(v,FF+6), *Branch(v,FF+7)); break;
  122.         case 9: (*f)(*Branch(v,FF), *Branch(v,FF+1), 
  123.             *Branch(v,FF+2), *Branch(v,FF+3), 
  124.             *Branch(v,FF+4), *Branch(v,FF+5), 
  125.             *Branch(v,FF+6), *Branch(v,FF+7),
  126.             *Branch(v,FF+8)); break;
  127.         default: syserr(MESS(2302, "Wrong size node in pt_node"));
  128.             /* NOTREACHED */
  129.     }
  130. }
  131.  
  132. /* ******************************************************************** */
  133. /* Type Check units */
  134. /* ******************************************************************** */
  135.  
  136. Hidden Procedure tc_unit(v) parsetree v; {
  137.     if (v != NilTree) tc_node(v, uni_tab);
  138. }
  139.  
  140. Hidden Procedure tc_howto_unit(name, formals, cmt,
  141.                   suite, refinement, reftab, nlocals)
  142.     parsetree suite, refinement;
  143.     value name, formals, cmt, reftab, nlocals; {
  144.  
  145.     tc_command(suite);
  146.     tc_unit(refinement);
  147. }
  148.  
  149. Hidden Procedure tc_yield_unit(name, adic, formals, cmt,
  150.                   suite, refinement, reftab, nlocals)
  151.     parsetree suite, refinement;
  152.     value name, adic, formals, cmt, reftab, nlocals; {
  153.  
  154.     refname = mk_text("returned value");
  155.     tc_command(suite);
  156.     release(refname); refname = Vnil;
  157.     tc_unit(refinement);
  158. }
  159.  
  160. Hidden Procedure tc_test_unit(name, adic, formals, cmt,
  161.                  suite, refinement, reftab, nlocals)
  162.     parsetree suite, refinement;
  163.     value name, adic, formals, cmt, reftab, nlocals; {
  164.  
  165.     tc_command(suite);
  166.     tc_unit(refinement);
  167. }
  168.  
  169. Hidden Procedure tc_refinement(name, cmt, suite, next)
  170.     parsetree suite, next; value name, cmt; {
  171.     value n1 = curtail(name, one);
  172.  
  173.     if (!Cap(charval(n1)))     /* should test for expression refinement */
  174.         refname = copy(name);
  175.     release(n1);
  176.     tc_command(suite);
  177.     if (refname NE Vnil) {
  178.         release(refname); refname = Vnil;
  179.     }
  180.     
  181.     tc_unit(next);
  182. }
  183.  
  184. /* ******************************************************************** */
  185. /* TypeCheck commands */
  186. /* ******************************************************************** */
  187.  
  188. Hidden Procedure tc_command(v) parsetree v; {
  189.     curline= v;
  190.     end_vars();
  191.     start_vars();
  192.     if (v != NilTree) tc_node(v, cmd_tab);
  193. }
  194.  
  195. Hidden Procedure tc_suite(lino, cmd, cmt, next)
  196.     parsetree cmd, next; value lino, cmt; {
  197.  
  198.     curlino= lino;
  199.     tc_command(cmd);
  200.     tc_command(next);
  201. }
  202.  
  203. Hidden Procedure tc_put(e, t) parsetree e, t; {
  204.     polytype te, tt, u;
  205.     te = pt_expr(e);
  206.     tt = pt_expr(t);
  207.     unify(te, tt, &u);
  208.     p_release(te); p_release(tt); p_release(u);
  209. }
  210.  
  211. Hidden Procedure tc_ins_rem(e, t) parsetree e, t; {
  212.     polytype t_list_e, tt, u;
  213.     t_list_e = mkt_list(pt_expr(e));
  214.     tt = pt_expr(t);
  215.     unify(tt, t_list_e, &u);
  216.     p_release(t_list_e); p_release(tt); p_release(u);
  217. }
  218.  
  219. Hidden Procedure tc_choose(t, e) parsetree t, e; {
  220.     polytype t_tlt_t, te, u;
  221.     t_tlt_t = mkt_tlt(pt_expr(t));
  222.     te = pt_expr(e);
  223.     unify(te, t_tlt_t, &u);
  224.     p_release(te); p_release(t_tlt_t); p_release(u);
  225. }
  226.  
  227. Hidden Procedure tc_draw(t) parsetree t; {
  228.     polytype t_number, tt, u;
  229.     tt = pt_expr(t);
  230.     t_number = mkt_number();
  231.     unify(tt, t_number, &u);
  232.     p_release(t_number); p_release(tt); p_release(u);
  233. }
  234.  
  235. Hidden Procedure tc_set_random(e) parsetree e; {
  236.     p_release(pt_expr(e));
  237. }
  238.  
  239. Hidden Procedure tc_delete(t) parsetree t; {
  240.     p_release(pt_expr(t));
  241. }
  242.  
  243. Hidden Procedure tc_check(c) parsetree c; {
  244.     tc_test(c);
  245. }
  246.  
  247. Hidden Procedure tc_nothing(t) parsetree t; {}
  248.  
  249. Hidden Procedure tc_write(nl1, e, nl2) parsetree e; value nl1, nl2; {
  250.     if (e != NilTree)
  251.         p_release(pt_expr(e));
  252. }
  253.  
  254. Hidden Procedure tc_read(t, e) parsetree t, e; {
  255.     polytype te, tt, u;
  256.     te = pt_expr(e);
  257.     tt = pt_expr(t);
  258.     unify(tt, te, &u);
  259.     p_release(te); p_release(tt); p_release(u);
  260. }
  261.  
  262. Hidden Procedure tc_raw_read(t) parsetree t; {
  263.     polytype t_text, tt, u;
  264.     t_text = mkt_text();
  265.     tt = pt_expr(t);
  266.     unify(tt, t_text, &u);
  267.     p_release(t_text); p_release(tt); p_release(u);
  268. }
  269.  
  270. Hidden Procedure tc_ifwhile(c, cmt, s) parsetree c, s; value cmt; {
  271.     tc_test(c);
  272.     tc_command(s);
  273. }
  274.  
  275. Hidden Procedure tc_for(t, e, cmt, s) parsetree t, e, s; value cmt; {
  276.     polytype t_tlt_t, te, u;
  277.  
  278.     t_tlt_t = mkt_tlt(pt_expr(t));
  279.     te = pt_expr(e);
  280.     unify(te, t_tlt_t, &u);
  281.     p_release(te); p_release(t_tlt_t); p_release(u);
  282.  
  283.     tc_command(s);
  284. }
  285.  
  286. Hidden Procedure tc_select(cmt, s) parsetree s; value cmt; {
  287.     tc_command(s);
  288. }
  289.  
  290. Hidden Procedure tc_tes_suite(lino, c, cmt, s, next) 
  291.     parsetree c, s, next; value lino, cmt; {
  292.     curlino= lino;
  293.     if (c != NilTree) {
  294.         tc_test(c);
  295.         tc_command(s);
  296.     }
  297.     tc_command(next);
  298. }
  299.  
  300. Hidden Procedure tc_else(lino, cmt, s) parsetree s; value lino, cmt; {
  301.     curlino= lino;
  302.     tc_command(s);
  303. }
  304.  
  305. Hidden Procedure tc_return(e) parsetree e; {
  306.     polytype te, tt, u;
  307.     te = pt_expr(e);
  308.     if (refname EQ Vnil)
  309.         error(MESS(2303, "RETURN not in YIELD unit or expression refinement"));
  310.     else {
  311.         tt = mkt_var(copy(refname));
  312.         unify(tt, te, &u);
  313.         p_release(tt); p_release(u);
  314.     }
  315.     p_release(te);
  316. }
  317.  
  318. Hidden Procedure tc_report(c) parsetree c; {
  319.     tc_test(c);
  320. }
  321.  
  322. Hidden Procedure tc_user_command(name, v) value name, v; {
  323.     parsetree e; value w= v;
  324.     while (w != Vnil) {
  325.         e= *Branch(w, ACT_EXPR);
  326.         if (e != NilTree)
  327.             p_release(pt_expr(e));
  328.         w= *Branch(w, ACT_NEXT);
  329.     }
  330. }
  331.  
  332. /* ******************************************************************** */
  333. /* calculate PolyType of EXPRessions
  334. /* ******************************************************************** */
  335.  
  336. Hidden polytype pt_expr(v) parsetree v; {
  337.     return pt_node(v, exp_tab);
  338. }
  339.         
  340. Hidden polytype pt_compound(e) parsetree e; {
  341.     return pt_expr(e);
  342. }
  343.  
  344. Hidden polytype pt_collateral(e) value e; {
  345.     intlet k, len= Nfields(e);
  346.     polytype tc;
  347.     tc = mkt_compound(len);
  348.     for (k = 0; k < len; k++)
  349.         putsubtype(pt_expr(*Field(e, k)), tc, k);
  350.     return tc;
  351. }
  352.  
  353. Hidden bool is_string(v, s) value v; string s; {
  354.     value t;
  355.     relation rel;
  356.     
  357.     rel = compare(v, t= mk_text(s));
  358.     release(t);
  359.     return (rel EQ 0 ? Yes : No);
  360. }
  361.  
  362. Hidden bool monf_on_number(n) value n; {
  363.     return (is_string(n, "~") ||
  364.         is_string(n, "+") ||
  365.         is_string(n, "-") ||
  366.         is_string(n, "*/") ||
  367.         is_string(n, "/*") ||
  368.         is_string(n, "root") ||
  369.         is_string(n, "abs") ||
  370.         is_string(n, "sign") ||
  371.         is_string(n, "floor") ||
  372.         is_string(n, "ceiling") ||
  373.         is_string(n, "round") ||
  374.         is_string(n, "sin") ||
  375.         is_string(n, "cos") ||
  376.         is_string(n, "tan") ||
  377.         is_string(n, "atan") ||
  378.         is_string(n, "exp") ||
  379.         is_string(n, "log")
  380.     );
  381. }
  382.  
  383. Hidden bool dyaf_on_number(n) value n; {
  384.     return (is_string(n, "+") ||
  385.         is_string(n, "-") ||
  386.         is_string(n, "*") ||
  387.         is_string(n, "/") ||
  388.         is_string(n, "**") ||
  389.         is_string(n, "root") ||
  390.         is_string(n, "round") ||
  391.         is_string(n, "mod") ||
  392.         is_string(n, "atan") ||
  393.         is_string(n, "log")
  394.     );
  395. }
  396.  
  397. Hidden polytype pt_monf(name, r, fct) parsetree r; value name, fct; {
  398.     polytype tr, tf, u;
  399.  
  400.     tr = pt_expr(r);
  401.  
  402.     if (monf_on_number(name)) {
  403.         polytype t_number = mkt_number();
  404.         unify(tr, t_number, &u);
  405.         p_release(u);
  406.         tf = t_number;
  407.     }
  408.     else if (is_string(name, "keys")) {
  409.         polytype t_table, t_keys;
  410.         t_keys = mkt_newvar();
  411.         t_table = mkt_table(p_copy(t_keys), mkt_newvar());
  412.         unify(tr, t_table, &u);
  413.         p_release(t_table); p_release(u);
  414.         tf = mkt_list(t_keys);
  415.     }
  416.     else if (is_string(name, "#")) {
  417.         polytype t_tlt = mkt_tlt(mkt_newvar());
  418.         unify(tr, t_tlt, &u);
  419.         p_release(t_tlt); p_release(u);
  420.         tf = mkt_number();
  421.     }
  422.     else if (is_string(name, "min") || is_string(name, "max")) {
  423.         polytype t_tlt_x, t_x;
  424.         t_x = mkt_newvar();
  425.         t_tlt_x = mkt_tlt(p_copy(t_x));
  426.         unify(tr, t_tlt_x, &u);
  427.         p_release(t_tlt_x); p_release(u);
  428.         tf = t_x;
  429.     }
  430.     else {
  431.         tf = mkt_newvar();
  432.     }
  433.     
  434.     p_release(tr);
  435.     return tf;
  436. }
  437.  
  438. Hidden polytype pt_dyaf(l, name, r, fct) parsetree l, r; value name, fct; {
  439.     polytype tl, tr, tf, u;
  440.     
  441.     tl = pt_expr(l);
  442.     tr = pt_expr(r);
  443.     if (dyaf_on_number(name)){
  444.         polytype t_number = mkt_number();
  445.         unify(tl, t_number, &u);
  446.         p_release(u);
  447.         unify(tr, t_number, &u);
  448.         p_release(u);
  449.         tf = t_number;
  450.     }
  451.     else if (is_string(name, "^")) {
  452.         polytype t_text = mkt_text();
  453.         unify(tl, t_text, &u);
  454.         p_release(u);
  455.         unify(tr, t_text, &u);
  456.         p_release(u);
  457.         tf = t_text;
  458.     }
  459.     else if (is_string(name, "^^")) {
  460.         polytype t_text = mkt_text(), t_number = mkt_number();
  461.         unify(tl, t_text, &u);
  462.         p_release(u);
  463.         unify(tr, t_number, &u);
  464.         p_release(u); p_release(t_number);
  465.         tf = t_text;
  466.     }
  467.     else if (is_string(name, "<<")
  468.          ||
  469.          is_string(name, "><")
  470.          ||
  471.          is_string(name, ">>"))
  472.     {
  473.         polytype t_number = mkt_number();
  474.         unify(tr, t_number, &u);
  475.         p_release(u); p_release(t_number);
  476.         tf = mkt_text();
  477.     }
  478.     else if (is_string(name, "#")) {
  479.         polytype t_tlt_l = mkt_tlt(p_copy(tl));
  480.         unify(tr, t_tlt_l, &u);
  481.         p_release(t_tlt_l); p_release(u);
  482.         tf = mkt_number();
  483.     }
  484.     else if (is_string(name, "min") || is_string(name, "max")) {
  485.         polytype t_tlt_l = mkt_tlt(p_copy(tl));
  486.         unify(tr, t_tlt_l, &u);
  487.         tf = p_copy(asctype(u));
  488.         p_release(t_tlt_l); p_release(u);
  489.     }
  490.     else if (is_string(name, "th'of")) {
  491.         polytype t_number, t_tlt_x, t_x;
  492.         t_number = mkt_number();
  493.         unify(tl, t_number, &u);
  494.         p_release(t_number); p_release(u);
  495.         t_x = mkt_newvar();
  496.         t_tlt_x = mkt_tlt(p_copy(t_x));
  497.         unify(tr, t_tlt_x, &u);
  498.         p_release(t_tlt_x); p_release(u);
  499.         tf = t_x;
  500.     }
  501.     else {
  502.         tf = mkt_newvar();
  503.     }
  504.     
  505.     p_release(tl);
  506.     p_release(tr);
  507.     
  508.     return tf;
  509. }
  510.  
  511. Hidden polytype pt_tag(name) value name; {
  512.     polytype var;
  513. /*
  514.  *    if (is_globalstring(name, "pi") || is_globalstring(name, "e"))
  515.  *        return mkt_number();
  516.  *    else
  517.  */
  518.     var = mkt_var(copy(name));
  519. add_var(var);
  520.      return var;
  521. }
  522.  
  523. Hidden polytype pt_tformal(name, number) value name, number; {
  524.     return pt_tag(name);
  525. }
  526.  
  527. Hidden polytype pt_tlocal(name, number) value name, number; {
  528.     return pt_tag(name);
  529. }
  530.  
  531. Hidden polytype pt_tglobal(name) value name; {
  532.     return pt_tag(name);
  533. }
  534.  
  535. Hidden polytype pt_tmystery(name, number) value name, number; {
  536.     return pt_tag(name);
  537. }
  538.  
  539. Hidden polytype pt_trefinement(name) value name; {
  540.     return pt_tag(name);
  541. }
  542.  
  543. Hidden polytype pt_tfun(name, fct) value name, fct; {
  544.     return pt_tag(name);
  545. }
  546.  
  547. Hidden polytype pt_tprd(name, fct) value name, fct; {
  548.     return pt_tag(name);
  549. }
  550.  
  551. Hidden polytype pt_number(v, t) value v, t; {
  552.     return mkt_number();
  553. }
  554.  
  555. Hidden polytype pt_text_dis(q, v) parsetree v; value q; {
  556.     while(v NE NilTree) {
  557.         switch (nodetype(v)) {
  558.         case TEXT_LIT:
  559.             v = *Branch(v, XLIT_NEXT);
  560.             break;
  561.         case TEXT_CONV:
  562.             p_release(pt_expr(*Branch(v, XCON_EXPR)));
  563.             v = *Branch(v, XCON_NEXT);
  564.             break;
  565.         default:
  566.             v = NilTree;
  567.         }
  568.     }
  569.     return mkt_text();
  570. }
  571.  
  572. Hidden polytype pt_elt_dis() {
  573.     return mkt_lt(mkt_newvar());
  574. }
  575.  
  576. Hidden polytype pt_list_dis(e) value e; {
  577.     intlet k, len= Nfields(e);
  578.     polytype tres = pt_expr(*Field(e, 0));
  579.     for (k = 1; k < len; k++) {
  580.         polytype te, u;
  581.         te = pt_expr(*Field(e, k));
  582.         unify(te, tres, &u);
  583.         p_release(te); p_release(tres);
  584.         tres = u;
  585.     }
  586.     return mkt_list(tres);
  587. }
  588.  
  589. Hidden polytype pt_range_dis(l, h) parsetree l, h; {
  590.     polytype tl, th, t_tn, tres, u;
  591.     t_tn = mkt_tn();
  592.     tl = pt_expr(l);
  593.     unify(tl, t_tn, &tres);
  594.     p_release(tl); p_release(t_tn);
  595.     th = pt_expr(h);
  596.     unify(th, tres, &u);
  597.     release(th); release(tres);
  598.     return mkt_list(u);
  599. }
  600.  
  601. Hidden polytype pt_tab_dis(e) value e; {
  602.     intlet k, len= Nfields(e);
  603.     polytype tresk, tresa;
  604.     tresk = pt_expr(*Field(e, 0));
  605.     tresa = pt_expr(*Field(e, 1));
  606.     for (k = 2; k < len; k += 2) {
  607.         polytype tk, ta, u;
  608.         tk = pt_expr(*Field(e, k));
  609.         unify(tk, tresk, &u);
  610.         p_release(tk); p_release(tresk);
  611.         tresk = u;
  612.         ta = pt_expr(*Field(e, k+1));
  613.         unify(ta, tresa, &u);
  614.         p_release(ta); p_release(tresa);
  615.         tresa = u;
  616.     }
  617.     return mkt_table(tresk, tresa);
  618. }
  619.  
  620. Hidden polytype pt_selection(t, k) parsetree t, k; {
  621.     polytype tt, ta, ttab, u;
  622.     tt = pt_expr(t);
  623.     ta = mkt_newvar();
  624.     ttab = mkt_table(pt_expr(k), p_copy(ta));
  625.     unify(tt, ttab, &u);
  626.     p_release(tt); p_release(ttab); p_release(u);
  627.     return ta;
  628. }
  629.  
  630. Hidden polytype pt_trim(l, r) parsetree l, r; {
  631.     polytype tl, tr, t_text, t_number, u;
  632.     
  633.     tl = pt_expr(l);
  634.     t_text = mkt_text();
  635.     unify(tl, t_text, &u);
  636.     p_release(tl); p_release(u);
  637.     tr = pt_expr(r);
  638.     t_number = mkt_number();
  639.     unify(tr, t_number, &u);
  640.     p_release(tr); p_release(t_number); p_release(u);
  641.     return t_text;
  642. }
  643.  
  644. Hidden polytype pt_unparsed(v, t) parsetree v, t; {
  645.     return mkt_newvar();
  646. }
  647.  
  648. /* ******************************************************************** */
  649. /* Type Check tests */
  650. /* ******************************************************************** */
  651.  
  652. Hidden Procedure tc_test(v) parsetree v; {
  653.     tc_node(v, tes_tab);
  654. }
  655.  
  656. Hidden Procedure tc_compound(c) parsetree c; {
  657.     tc_test(c);
  658. }
  659.  
  660. Hidden Procedure tc_junction(l, r) parsetree l, r; {
  661.     tc_test(l);
  662.     tc_test(r);
  663. }
  664.  
  665. Hidden Procedure tc_not(r) parsetree r; {
  666.     tc_test(r);
  667. }
  668.  
  669. Hidden Procedure tc_in_quantification(t, e, c) parsetree t, e, c; {
  670.     polytype t_tlt_t, te, u;
  671.  
  672.     t_tlt_t = mkt_tlt(pt_expr(t));
  673.     te = pt_expr(e);
  674.     unify(te, t_tlt_t, &u);
  675.     p_release(te); p_release(t_tlt_t); p_release(u);
  676.     
  677.     tc_test(c);
  678. }
  679.  
  680. Hidden Procedure tc_p_quantification(t, e, c) parsetree t, e, c; {
  681.     intlet k, len;
  682.     value ct;         /* the Collateral Tag in t */
  683.     polytype t_text, te, u;
  684.  
  685.     t_text = mkt_text();
  686.     
  687.     ct = *Branch(t, COLL_SEQ);
  688.     len = Nfields(ct);
  689.     k_Over_len {
  690.         polytype ttag;
  691.         ttag = mkt_var(copy(*Branch(*Field(ct, k), TAG_NAME)));
  692. add_var(ttag);
  693.         unify(ttag, t_text, &u);
  694.         p_release(ttag); p_release(u);
  695.     }
  696.     
  697.     te = pt_expr(e);
  698.     unify(te, t_text, &u);
  699.     p_release(te); p_release(t_text); p_release(u);
  700.     
  701.     tc_test(c);
  702. }
  703.  
  704. Hidden Procedure tc_tag(name) value name; {}
  705.  
  706. Hidden Procedure tc_tformal(name, number) value name, number; {
  707.     tc_tag(name);
  708. }
  709.  
  710. Hidden Procedure tc_tlocal(name, number) value name, number; {
  711.     tc_tag(name);
  712. }
  713.  
  714. Hidden Procedure tc_tglobal(name) value name; {
  715.     tc_tag(name);
  716. }
  717.  
  718. Hidden Procedure tc_tmystery(name, number) value name, number; {
  719.     tc_tag(name);
  720. }
  721.  
  722. Hidden Procedure tc_trefinement(name) value name; {
  723.     tc_tag(name);
  724. }
  725.  
  726. Hidden Procedure tc_tfun(name, fct) value name, fct; {
  727.     tc_tag(name);
  728. }
  729.  
  730. Hidden Procedure tc_tprd(name, fct) value name, fct; {
  731.     tc_tag(name);
  732. }
  733.  
  734. Hidden Procedure tc_monprd(name, r, pred) parsetree r; value name, pred; {
  735.     p_release(pt_expr(r));
  736. }
  737.  
  738. Hidden Procedure tc_dyaprd(l, name, r, pred) parsetree l, r; value name, pred; {
  739.     polytype tl, tr;
  740.     tl = pt_expr(l);
  741.     tr = pt_expr(r);
  742.     if (is_string(name, "in") || is_string(name, "not'in")) {
  743.         polytype t_tlt_l, u;
  744.         t_tlt_l = mkt_tlt(p_copy(tl));
  745.         unify(tr, t_tlt_l, &u);
  746.         p_release(t_tlt_l); p_release(u);
  747.     }
  748.     p_release(tl); p_release(tr);
  749. }
  750.  
  751. Forward polytype pt_relop();
  752.  
  753. Hidden Procedure tc_relop(l, r) parsetree l, r; {
  754.     p_release(pt_relop(l, r));
  755. }
  756.  
  757. Hidden polytype pt_relop(l, r) parsetree l, r; {
  758.     polytype tl, tr, u;
  759.  
  760.     if (Comparison(nodetype(l)))
  761.         tl = pt_relop(*Branch(l, REL_LEFT), *Branch(l, REL_RIGHT));
  762.     else
  763.         tl = pt_expr(l);
  764.     tr = pt_expr(r);
  765.     unify(tl, tr, &u);
  766.     p_release(tl); p_release(tr);
  767.     return u;
  768. }
  769.  
  770. Hidden Procedure tc_unparsed(c, t) parsetree c, t; {}
  771.  
  772. Hidden Procedure uni_bad() { syserr(MESS(2304, "bad uni node in type check")); }
  773. Hidden Procedure cmd_bad() { syserr(MESS(2305, "bad cmd node in type check")); }
  774. Hidden polytype exp_bad() { syserr(MESS(2306, "bad exp node in type check"));
  775.                 return (polytype) 0; }
  776. Hidden Procedure tes_bad() { syserr(MESS(2307, "bad tes node in type check")); }
  777.  
  778. Visible Procedure inittyp() {
  779.     int i;
  780.     for (i= 0; i<TABSIZE; i++) {
  781.          uni_tab[i]= uni_bad;
  782.          cmd_tab[i]= cmd_bad;
  783.          exp_tab[i]= exp_bad;
  784.          tes_tab[i]= tes_bad;
  785.     }
  786.  
  787.     uni_tab[HOW_TO]=    tc_howto_unit;
  788.     uni_tab[YIELD]=        tc_yield_unit;
  789.     uni_tab[TEST]=        tc_test_unit;
  790.     uni_tab[REFINEMENT]=    tc_refinement;
  791.  
  792.     cmd_tab[SUITE]=          tc_suite;
  793.     cmd_tab[PUT]=           tc_put;
  794.     cmd_tab[INSERT]=    tc_ins_rem;
  795.     cmd_tab[REMOVE]=    tc_ins_rem;
  796.     cmd_tab[CHOOSE]=    tc_choose;
  797.     cmd_tab[DRAW]=           tc_draw;
  798.     cmd_tab[SET_RANDOM]=      tc_set_random;
  799.     cmd_tab[DELETE]=    tc_delete;
  800.     cmd_tab[CHECK]=           tc_check;
  801.     cmd_tab[SHARE]=           tc_nothing;
  802.     cmd_tab[WRITE]=           tc_write;
  803.     cmd_tab[READ]=           tc_read;
  804.     cmd_tab[READ_RAW]=    tc_raw_read;
  805.     cmd_tab[IF]=           tc_ifwhile;
  806.     cmd_tab[WHILE]=           tc_ifwhile;
  807.     cmd_tab[FOR]=           tc_for;
  808.     cmd_tab[SELECT]=    tc_select;
  809.     cmd_tab[TEST_SUITE]=      tc_tes_suite;
  810.     cmd_tab[ELSE]=           tc_else;
  811.     cmd_tab[QUIT]=           tc_nothing;
  812.     cmd_tab[RETURN]=    tc_return;
  813.     cmd_tab[REPORT]=    tc_report;
  814.     cmd_tab[SUCCEED]=    tc_nothing;
  815.     cmd_tab[FAIL]=           tc_nothing;
  816.     cmd_tab[USER_COMMAND]=    tc_user_command;
  817.     cmd_tab[EXTENDED_COMMAND]= tc_nothing;
  818.     exp_tab[TAG]=        pt_tag;
  819.     tes_tab[TAG]=        tc_tag;
  820.     exp_tab[TAGformal]=    pt_tformal;
  821.     tes_tab[TAGformal]=    tc_tformal;
  822.     exp_tab[TAGlocal]=    pt_tlocal;
  823.     tes_tab[TAGlocal]=    tc_tlocal;
  824.     exp_tab[TAGglobal]=    pt_tglobal;
  825.     tes_tab[TAGglobal]=    tc_tglobal;
  826.     exp_tab[TAGmystery]=    pt_tmystery;
  827.     tes_tab[TAGmystery]=    tc_tmystery;
  828.     exp_tab[TAGrefinement]=    pt_trefinement;
  829.     tes_tab[TAGrefinement]=    tc_trefinement;
  830.     exp_tab[TAGzerfun]=    pt_tfun;
  831.     tes_tab[TAGzerfun]=    tc_tfun;
  832.     exp_tab[TAGzerprd]=    pt_tprd;
  833.     tes_tab[TAGzerprd]=    tc_tprd;
  834.     
  835.     exp_tab[COMPOUND]=    pt_compound;
  836.     tes_tab[COMPOUND]=    tc_compound;
  837.     exp_tab[COLLATERAL]=    pt_collateral;
  838.     exp_tab[SELECTION]=    pt_selection;
  839.     exp_tab[BEHEAD]=    pt_trim;
  840.     exp_tab[CURTAIL]=    pt_trim;
  841.  
  842.     exp_tab[UNPARSED]=    pt_unparsed;
  843.     tes_tab[UNPARSED]=    tc_unparsed;
  844.     
  845.     exp_tab[MONF]=           pt_monf;
  846.     exp_tab[DYAF]=           pt_dyaf;
  847.     exp_tab[NUMBER]=    pt_number;
  848.     exp_tab[TEXT_DIS]=    pt_text_dis;
  849.     exp_tab[ELT_DIS]=    pt_elt_dis;
  850.     exp_tab[LIST_DIS]=    pt_list_dis;
  851.     exp_tab[RANGE_DIS]=       pt_range_dis;
  852.     exp_tab[TAB_DIS]=    pt_tab_dis;
  853.     
  854.     tes_tab[AND]=           tc_junction;
  855.     tes_tab[OR]=           tc_junction;
  856.     tes_tab[NOT]=           tc_not;
  857.     tes_tab[SOME_IN]=    tc_in_quantification;
  858.     tes_tab[EACH_IN]=    tc_in_quantification;
  859.     tes_tab[NO_IN]=           tc_in_quantification;
  860.     tes_tab[SOME_PARSING]=    tc_p_quantification;
  861.     tes_tab[EACH_PARSING]=    tc_p_quantification;
  862.     tes_tab[NO_PARSING]=      tc_p_quantification;
  863.     tes_tab[MONPRD]=    tc_monprd;
  864.     tes_tab[DYAPRD]=    tc_dyaprd;
  865.     tes_tab[LESS_THAN]=       tc_relop;
  866.     tes_tab[AT_MOST]=    tc_relop;
  867.     tes_tab[GREATER_THAN]=    tc_relop;
  868.     tes_tab[AT_LEAST]=    tc_relop;
  869.     tes_tab[EQUAL]=           tc_relop;
  870.     tes_tab[UNEQUAL]=    tc_relop;
  871. }
  872.